\ iF32Harness.fth - FCOM portability harness for iForth32
\ Tom Dixon
\ 10/16/2008


needs -winconst

\ **** Error Handling ****

: ?throw ( flag n -- ) 
   swap if $throw else drop then ;

: err_NotDispatch       c" Dispatch Interface not returned"     ;   
: err_InvBind           c" Invalid Bind Type"                   ; 
: err_Bind              c" Unable to Bind to type"              ; 
: err_GetTypeInfo       c" Unable to get type info"             ; 
: err_GetDoc            c" Unable to get Documentation"         ; 
: err_LoadTypeLib       c" Error Loading Type Library"          ; 
: err_GetTypeComp       c" Error Getting TypeComp"              ; 
: err_NoVI              c" No Virtual Interface"                ; 
: err_NotIF             c" Not An Interface"                    ; 
: err_VarStFull         c" Variant Stack Full"                  ; 
: err_CantDispatch      c" Unable to Call Dispatch"             ; 
: err_NoProgID          c" Unable to Find ProgID"               ; 
: err_NoIUnknown        c" Unable to Get IUnknown"              ; 
: err_NoValStruct       c" Not a valid COM Structure"           ; 
: err_BadAlloc          c" Unable to Allocate String"           ; 
: err_GUIDlen           c" Invalid Guid Length"                 ; 
: err_BadCLSID          c" Not a CLSID"                         ; 
: err_IUnknown          c" Unable to get IUnknown interface"    ; 
: err_AXcreate          c" Unable to create ActiveX Control"    ; 
: err_noIF              c" Unable to get Interface"             ; 


\ **** Missing Synonym ****
[defined] synonym 0= [if]
  : SYNONYM 
     : 
     BL WORD FIND 1 = IF IMMEDIATE THEN COMPILE, 
     POSTPONE ; ; 
[then]


\ **** Windows API Access ****

library kernel32
library oleaut32
library ole32
library atl


\ **** GUID calls ****

2 IMPORT StringFromCLSID

: fStringFromCLSID ( ppsz rclsid -- res ) 
   swap StringFromCLSID ;


\ **** UNICODE Calls ****

6 IMPORT MultiByteToWideChar
8 IMPORT WideCharToMultiByte
2 IMPORT SysAllocStringLen
1 IMPORT SysFreeString 

: fMultiByteToWideChar ( wclen *wc mblen *mb flags cp -- int )
   LOCALS| l1 l2 l3 l4 l5 l6 |
   l1 l2 l3 l4 l5 l6 MultiByteToWideChar ;
   
: fWideCharToMultiByte ( *used *def mblen *mb wclen *wc flags cp -- len )
   LOCALS| l1 l2 l3 l4 l5 l6 l7 l8 |
   l1 l2 l3 l4 l5 l6 l7 l8 WideCharToMultiByte ;
 
: fSysAllocStringLen ( cch pch -- addr ) 
   swap SysAllocStringLen ;
   
: fSysFreeString ( bstr -- ) 
   SysFreeString drop ;

SYNONYM MB>WC fMultiByteToWideChar
SYNONYM WC>MB fWideCharToMultiByte
   
   
\ **** FCOM calls ****

5 IMPORT CoCreateInstance
2 IMPORT CLSIDFromProgID
5 IMPORT LoadRegTypeLib
2 IMPORT LoadTypeLib
1 IMPORT CoTaskMemFree
1 IMPORT CoInitialize
   
: fCoCreateInstance ( ppv riid context pUnkOuter rclsid -- res )
   LOCALS| l1 l2 l3 l4 l5 |
   l1 l2 l3 l4 l5 CoCreateInstance ;
   
: fCLSIDFromProgID ( pclsid pprogid -- res )
   swap CLSIDFromProgID ;
   
: fLoadRegTypeLib ( pptlib lcid wverminor wvermajor rguid -- res )
   LOCALS| l1 l2 l3 l4 l5 |
   l1 l2 l3 l4 l5 LoadRegTypeLib ;
   
: fLoadTypeLib ( pptlib szFile -- res ) 
   swap LoadTypeLib ;

: fCoTaskMemFree ( *pv -- ) 
   CoTaskMemFree drop ;

: fCoInitialize ( n -- res ) 
   CoInitialize ;
   
\ **** ActiveX calls ****

4 IMPORT AtlAxCreateControl
2 IMPORT AtlAxGetControl

: fAtlAxCreateControl ( ppUnk pstream hWnd lpszName -- res )
   LOCALS| l1 l2 l3 l4 |
   l1 l2 l3 l4 AtlAxCreateControl ;
   
: fAtlAxGetControl ( pptlib szFile -- res )
   swap AtlAxGetControl ;

\ **** iForth Specific Behavior ****

CODE FCOM-CALL ( x1 x2 .. xn a -- x ) 
   finit,        \ finit,
   $87 c, $E5 c, \ ebp -> esp xchg,
   $56 c,        \ esi push,
   $57 c,        \ edi push,
   $52 c,        \ edx push,
   $53 c,        \ ebx push, 
   $87 c, $E5 c, \ ebp -> esp xchg,
   $58 c,        \ eax pop,
   $FF c, $D0 c, \ eax call,
   $50 c,        \ eax push,
   $87 c, $E5 c, \ ebp -> esp xchg,
   $5B c,        \ ebx pop,
   $5A c,        \ edx pop,
   $5F c,        \ edi pop,
   $5E c,        \ esi pop,
   $87 c, $E5 c, \ ebp -> esp xchg,
   $FF c, $E3 c, \ ebx jmp,
END-CODE
   
: INTERFACE-CALL ( n1 n2 n3 ... nx a indx ) \ vtable call
   >r @ dup @ r> cells + @ FCOM-CALL ;

: RUN-INTERFACE ( pointer imethod -- ) \ runtime interface call
   cell+ @ interface-call ;

: COMPILE-INTERFACE ( pointer imethod -- ) \ fast compile interface call
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @
   cell+ @ cells POSTPONE LITERAL 
   POSTPONE + 
   POSTPONE @ 
   POSTPONE FCOM-CALL ;

: RUN-VTABLE ( pointer offset -- ) 
   swap @ dup @ rot + @ FCOM-CALL ;

: COMPILE-VTABLE ( pointer offset -- ) 
   POSTPONE @ 
   POSTPONE dup 
   POSTPONE @ 
   POSTPONE LITERAL
   POSTPONE + 
   POSTPONE @ 
   POSTPONE FCOM-CALL ;


: laddr ( <name> -- addr ) \ returns the address of the local variable
   ['] 'of execute ; IMMEDIATE


: discard-sinline ( -- ) \ flag to compiler inliner (not needed in iforth)
   ; immediate


\ Global searching - This is system specific.
\ This also contains a hack for getting global windows constants

: WConstfind ( c-addr u -- val flag )
   0 LOCAL res
   'OF res FindConstant res swap ;


defer COMsearcher ( str len -- flag )

\ Until it gets re-defined
:noname 2drop false ; is COMsearcher 

: (comfind) ( addr len -- addr len 0 | n 1 | d 2 | f 9 ) 
   [ 'number @ ] literal execute \ call previous number?
   dup if exit else drop then \ it was acually a number
   2dup 2>r WConstfind if 
     2r> 2drop 1 exit 
   then 2r> 0 ;
   
' (comfind) 'NUMBER ! 

: interpret ( caddr -- ) LOCALS| caddr |
  caddr [ 'eval @ ] literal catch dup -13 = if 
    2drop caddr count COMsearcher 0= if 
      caddr -13 throw
    then
  else 
    drop 
  then ;

' interpret 'eval ! 


: AtCold ( xt -- ) \ run the xt on startup
   'Boot ! ;

: AtExit ( xt -- ) \ run the xt on exit - iforth does not have!
   drop ;

\ **** Other Odds and Ends ****
: W, ( n -- ) 
   dup $FF and c, 8 rshift $FF and c, ;

: W! ( n addr -- ) 
   over $FF and over c! swap 8 rshift $FF and swap 1+ c! ;

: W@ ( addr -- n ) @ $FFFF and ;

: istr= ( str len str len -- flag )
   >r over r> <> if 
     2drop drop false exit 
   then 
   swap bounds ?do
     dup c@ >upc i c@ >upc <> if
       drop false unloop exit
     then
     1+ 
   loop drop true ;

: place ( addr len addr -- ) 
   2dup c! 1+ -rot bounds ?do 
     i c@ over c! 1+ 
   loop drop ;
   
\ Must redefine , because iforth wants to always align on 
\ any thing commented into the dictionary (which really bites)
: , ( n -- ) 
   here 1 cells allot ! ;